home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / debug / for-debugging.scm < prev    next >
Text File  |  1995-10-13  |  1KB  |  60 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; --------------------
  5.  
  6. ; Fake interrupt and exception system.
  7. ; This needs to be reconciled with alt/primitives.scm.
  8.  
  9. (define (with-exceptions thunk)
  10.   (with-handler
  11.        (lambda (c punt)
  12.      (cond ((and (exception? c)
  13.              (procedure? (get-exception-handler)))
  14.         (handle-exception-carefully c))
  15.            ((interrupt? c)
  16.         (if (not (deal-with-interrupt c))
  17.             (punt)))
  18.            ;; ((vm-return? c)
  19.            ;;  (vm-return (cadr c)))
  20.            (else
  21.         (punt))))
  22.      thunk))
  23.  
  24. (define (handle-exception-carefully c)
  25.   (display "(Exception: ") (write c) (display ")") (newline)
  26.   (noting-exceptional-context c
  27.     (lambda ()
  28.       (raise-exception (exception-opcode c)
  29.                (exception-arguments c)))))
  30.  
  31. (define (noting-exceptional-context c thunk)
  32.   (call-with-current-continuation
  33.     (lambda (k)
  34.       ;; Save for future inspection, just in case.
  35.       (set! *exceptional-context* (cons c k))
  36.       (thunk))))
  37.  
  38. (define *exceptional-context* #f)
  39.  
  40. (define (deal-with-interrupt c)
  41.   (noting-exceptional-context c
  42.     (lambda ()
  43.       (maybe-handle-interrupt
  44.        (if (and (pair? (cdr c)) (integer? (cadr c)))
  45.        (cadr c)
  46.        (enum interrupt keyboard))))))
  47.  
  48. ; (define (poll-for-interrupts) ...)
  49.  
  50.  
  51. ; Get the whole thing started
  52.  
  53. (define (?start-with-exceptions entry-point arg)
  54.   (with-exceptions
  55.    (lambda ()
  56.      (?start entry-point arg))))
  57.  
  58. (define (in struct form)
  59.   (eval form (structure-package struct)))
  60.